;; Grammatical Evolution in Clojure.
;;
;; Copyright 2011:
;; James McDermott <jamesmichaelmcdermott@gmail.com>
;; Mark Wagy <mark.wagy@gmail.com>
;;
;; This file is part of p-gen, a p-systems and evolutionary system
;; written in Clojure.
;;
;; p-gen is licensed under GNU GPL v3.
;;
;; http://code.google.com/p/p-gen/

;; imports
(refer 'clojure.set)

;; Fitness is maximised. An invalid individual gets negative fitness."
(def default-fitness -1.0)

(defn print-rule
  "Print a rule. A rule's first element is the LHS, the rest is the
RHS: each element in the RHS is a possible production consisting of a
list of symbols."
  [r]
  (do
	(println (first r))
	(map println (rest r))))

(defn print-grammar
  "Print a grammar, which consists of multiple rules."
  [g]
  (if (seq g)
    (do
      (print-rule (first g))
      (print-grammar (rest g)))))

(defn get-type
  "Derivation trees have a type associated with each node. For now
this type will just be a symbol."
  [s]
  s)

(defn non-terminal-p
  "Is a symbol a non-terminal? If enclosed in angle brackets it is."
  [s]
  (and
   (.startsWith (str s) "<")
   (.endsWith (str s) ">")))

(defn rule-match
  "Given a grammar and a lhs, return the corresponding rhs."
  [grammar nt]
  (rest (first (filter #(= nt (first %1)) grammar))))

(defn derive-tree
  "Given a grammar, and a genotype, and a partial derivation (a list
of strings): derive one more step, and recurse. Each gene of the
genotype chooses one of the productions in the appropriate rule at
each derivation step. Given only a grammar and a genotype, call self
with the start symbol as the partial derivation. FIXME: should not use
a codon if the rule has only a single production on RHS."

  ([grammar genotype]
	 (let
		 [
		  ;; get start symbol
		  start (first (first grammar))
		  ]

	   (derive-tree grammar (list start) genotype)))
  ([grammar ss genotype]
	 (let
		 [
		  ;; Break partial derivation ss up into parts
		  preceding (take-while #(not (non-terminal-p %1)) ss)
		  following-tmp (drop-while #(not (non-terminal-p %1)) ss)
		  following (rest following-tmp)

		  ;; Find lhs and rhs
		  lhs (first following-tmp)
		  rhs (rule-match grammar lhs)
		  ]

	   ;; This is just ugly debugging printing
	   ;; (println "ss:" ss "lhs:" lhs "rhs:" rhs "genotype:" genotype)

	   (if (not lhs)
		 ;; Only terminals remain: concatenate the final derivation to
		 ;; get output
		 (apply str preceding)

		 ;; Otherwise, non-terminals remain to be mapped.
		 (if (< (count genotype) 1)

		   ;; If genotype is empty, fail.
		   nil

		   ;; If genotype is non-empty:
		   (let
			   [
				;; Use the first gene...
				gene (genotype 0)
				new-genotype (subvec genotype 1)

				;; ... to find a production by mod rule ...
				prod (nth rhs (mod gene (count rhs)))]

			 ;; ... and recurse.
			 (derive-tree
			  grammar
			  (concat preceding prod following)
			  new-genotype)))))))


;; An object storing the evolutionary parameters
(defrecord parameters [fitness-fn popsize generations grammar indsize])

;; An individual consists of an array-genotype, a string-phenotype
;; and a numerical fitness.
(defrecord individual [genotype phenotype fitness])

;; An object for storing per-generation statistics.
(defrecord statistics [best-fitness mean-fitness min-length max-length])

(defn make-individual
  "Make an individual from a genotype. Specify grammar and fitness-fn
if you want the phenotype and fitness to be set correctly. If genotype
is insufficient to complete derivation, individual is deemed invalid
and a default (bad) fitness is awarded."

  ([genotype grammar fitness-fn]
	 (let [phenotype (derive-tree grammar genotype)]
	   (if phenotype
		 (let [fitness (fitness-fn phenotype)]
		   (new individual genotype phenotype fitness))
		 (new individual genotype "" default-fitness))))

  ([genotype]
	 (new individual genotype "" 0)))

(defn tree-crossover
  "Cross two trees over -- this is not finished."
  [x y]
  (let
	  [

	;; get length
	xlen (count (flatten x))
	ylen (count (flatten y))

	;; crossover points, one in each
	xpt (int (* xlen (rand)))
	ypt (int (* ylen (rand)))

	valid-xover-symbols (intersection
						 (set (map get-type (flatten x)))
						 (set (map get-type (flatten y))))]
	valid-xover-symbols))


(defn array-crossover
  "Cross two arrays over."
  [x y]
  (let
	  [

	;; get length
	xlen (count x)
	ylen (count y)

	;; crossover points, one in each
	xpt (int (* xlen (rand)))
	ypt (int (* ylen (rand)))

	;; perform crossover
	c0 (apply vector (concat (drop-last (- xlen xpt) x) (drop ypt y)))
	c1 (apply vector (concat (drop-last (- ylen ypt) y) (drop xpt x)))]

	[c0 c1]))

(defn crossover
  "Cross two individuals over. Assume genotypes are integer arrays."
  [x y]
  (map make-individual (array-crossover (:genotype x)
										(:genotype y))))


(defn array-mutation
  "Given an integer array, return a new mutated version."
  [x]
  (let
	  [
	;; get length
	xlen (count x)
	pmut 0.01]

	(defn mutate-int [i]
	  (if (< (rand) pmut)
		  (int (* (rand) 100))
		i))

	(apply vector (map mutate-int x))))

(defn mutation
  "Mutate an individual. Assume genotype is an integer array."
  [x]
  (make-individual (array-mutation (:genotype x))))

(defn make-random-genome
  "Make a random genome of a given size."
  [size]
  (apply vector (for [x (range size)] (int (* (rand) 100)))))

(defn make-random-ind
  "Make a random individual of a given size."
  [indsize]
  (make-individual (make-random-genome indsize)))

(defn make-random-population
  "Make a random population of a given size, containing individuals of a given size."
  [popsize indsize]
  (for [x (range popsize)] (make-random-ind indsize)))

(defn random-choose-n
  "Choose n unique elements from coll, randomly."
  [coll n]
  (take n (distinct (for [x (range 10000000)] (rand-nth coll)))))

(defn tournament
  "Pick size individuals at random, sort, and return the last
  (ie highest fitness)."
  [population size]
  (last (sort-by :fitness (random-choose-n population size))))

(defn population-stats
  "Given a population, get some statistics."

  [population]
  (let [fitness-vals (map :fitness population)
		genome-lens (map #(count (:genotype %1)) population)]
	(new statistics
		 (apply max fitness-vals)
		 (/ (apply + fitness-vals) (count fitness-vals))
		 (apply min genome-lens)
		 (apply max genome-lens))))



(defn eval-population
  "For each individual, get its genotype, derive the phenotype string
  and calculate fitness. Make a new population out of these
  individuals. Print some stats. Return the same population (really a
  new population object) now with phenotype and fitness set for each
  individual."

  [population parameters]
  (let [
		fitness-fn (:fitness-fn parameters)
		grammar (:grammar parameters)
		genotypes (map :genotype population)
		new-pop (map #(make-individual % grammar fitness-fn) genotypes)
		]
	(println (population-stats new-pop))
	new-pop))


(defn step-population
  "Population is a collection of individuals. We evaluate them all
  first. Then select good ones, cross over, mutate, and repeat."

  [population parameters]
  (let [
		popsize (count population)
		old-pop (eval-population population parameters)
		]

	;; Repeatedly get two individuals and cross them over.
	(take popsize
		  (map mutation
			   (apply concat (for [x (range 10000000)]
							   (crossover (tournament old-pop 7)
										  (tournament old-pop 7))))))))


(defn evolve
  "Loop for a given number of generations: at each generation, step
  the population."

  [parameters]
  ;; Evaluate the population resulting from the loop.
  (eval-population
	(loop
		[
		 population
		 (make-random-population (:popsize parameters) (:indsize parameters))
		 generation
		 0
		 ]
	  (if (> generation (:generations parameters))
		population
		(recur (step-population population parameters) (inc generation))))
	parameters))



;; Some useful values for testing.

;; A global variable -- later, grammar will be read and processed from
;; a file. Grammar is a list of rules. Each rule is a head (lhs) and
;; the rest (rhs). lhs is a symbol. rhs is a list of productions. Each
;; production is a list of symbols or strings (can be useful to use a
;; string where whitespace is a concern).
(def grammar
	 '(
	   (<a> (aa <b>) (a <b>))
	   (<b> (aba <c>) (aba))
	   (<c> (d) (<d> d))
	   (<d> (d) (aba d))))

;; a fitness function that just counts the length of the phenotype
;; string. Note that fitness functions operate on phenotype strings
;; not on individuals.
(defn f [phenotype] (count phenotype))

;; an example parameters object
(def p (new parameters f 10 10 grammar 10))




;; ;; Some tests.

;; ;; Two integer chromosomes
;; (def x [1 3 20 10 17 4 8 12])
;; (def y [4 3 5 8 19])
;; (def z [1])

;; (array-mutation x)
;; (array-crossover x y)


;; ;; A non-deterministic derivation. Genes determine derivation. Returns
;; ;; a string.
;; (derive-tree grammar [0 1 1 1 1 1 1 1 1])

;; ;; fails because genotype isn't long enough for a full derivation -
;; ;; returns nil.
;; (derive-tree grammar [0])

;; ;; make an initial population and step it a few times
;; (def pop1 (make-random-population 10 100))
;; (def pop2 (step-population pop1 s))
;; (def pop3 (step-population pop2 s))
;; (def pop4 (step-population pop3 s))
;; (def pop5 (eval-population pop4 s))
;; (print pop5)

;; ;; Usage as follow:
;; (evolve p)




;; Some Turtle examples.

(import cheloniidae.Turtle)
(import cheloniidae.TurtleWindow)
(import cheloniidae.StandardRotationalTurtle)

(def w (new TurtleWindow))
(def t (new StandardRotationalTurtle))
(. w add t)
(. w setVisible true)

(def turtle-grammar
	 '((<p> (<cmd> <cmd>) (<p> <cmd>))
	   (<cmd> ("(. t move " <double> ") ") ("(. t turn " <double> ") "))
	   (<double> (10.0) (20.0) (30.0) (40.0) (50.0) (60.0))))


(load-string "(+ 1 2)") ;; reads a string and evals it -> 3.
(load-string "(. t move 40.0)(. t move 20.0)(. t turn 30.0)")
(defn user [phenotype]
  ;; show individual and do y-or-n-p
  (do
	(load-string phenotype)
	1.0))

(def p (new parameters user 10 10 turtle-grammar 100))
(evolve p)
